home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / VARARG.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  8.2 KB  |  280 lines
  1. ; VARARGS.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*    "Funarg" ie Variable Lengths Function Backups for Primitives    *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 13 Apr 87: Funarg handler for make/string (tc)            *
  18. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  19. ;*                                    *
  20. ;*                    ``In nomine omnipotentii dei''    *
  21. ;************************************************************************
  22.  
  23. ;                   NOTE:                   ;
  24. ;                                       ;
  25. ;    Most of these routines are defined in terms of primitive       ;
  26. ;    operations with the same name.    Thus, they must be compiled       ;
  27. ;    with PCS-INTEGRATE-PRIMITIVES set true.  Also, be sure not to       ;
  28. ;    use DEFREC!, LETREC, REC, etc., incorrectly.               ;
  29.  
  30. (define *                        ; *
  31.   (lambda args    ; for funarg use, don't use DEFREC!
  32.     (cond ((null? args)
  33.        1)
  34.       (else (do ((a (car args) (* a (car x)))
  35.           (x (cdr args) (cdr x)))
  36.          ((null? x) a))))))
  37.  
  38. (define +                        ; +
  39.   (lambda args    ; for funarg use, don't use DEFREC!
  40.     (cond ((null? args)
  41.        0)
  42.       (else (do ((a (car args) (+ a (car x)))
  43.           (x (cdr args) (cdr x)))
  44.          ((null? x) a))))))
  45.  
  46. (define -                        ; -
  47.   (lambda args    ; for funarg use, don't use DEFREC!
  48.     (cond ((null? args)
  49.        0)
  50.       ((null? (cdr args))
  51.        (- (car args)))
  52.       (else (do ((a (car args) (- a (car x)))
  53.           (x (cdr args) (cdr x)))
  54.          ((null? x) a))))))
  55.  
  56. (define /                        ; /
  57.   (lambda args    ; for funarg use, don't use DEFREC!
  58.     (cond ((null? args)
  59.        1)
  60.       ((null? (cdr args))
  61.        (/ 1 (car args)))
  62.       (else (do ((a (car args) (/ a (car x)))
  63.           (x (cdr args) (cdr x)))
  64.          ((null? x) a))))))
  65.  
  66. (define <=                        ; <=
  67.   (lambda args
  68.     (cond ((null? (cdr args)) #T)
  69.       (else (do ((args args (cdr args))
  70.              (res #T (and res (<= (car args) (cadr args)))))
  71.             ((or (not res) (null? (cdr args))) res))))))
  72.  
  73. (define >=                        ; >=
  74.   (lambda args
  75.     (cond ((null? (cdr args)) #T)
  76.       (else (do ((args args (cdr args))
  77.              (res #T (and res (>= (car args) (cadr args)))))
  78.             ((or (not res) (null? (cdr args))) res))))))
  79.  
  80. (define <                        ; <
  81.   (lambda args
  82.     (cond ((null? (cdr args)) #T)
  83.       (else (do ((args args (cdr args))
  84.              (res #T (and res (< (car args) (cadr args)))))
  85.             ((or (not res) (null? (cdr args))) res))))))
  86.  
  87. (define >                        ; >
  88.   (lambda args
  89.     (cond ((null? (cdr args)) #T)
  90.       (else (do ((args args (cdr args))
  91.              (res #T (and res (> (car args) (cadr args)))))
  92.             ((or (not res) (null? (cdr args))) res))))))
  93.  
  94. (define =                        ; =
  95.   (lambda args
  96.     (cond ((null? (cdr args)) #T)
  97.       (else (do ((args args (cdr args))
  98.              (res #T (and res (= (car args) (cadr args)))))
  99.             ((or (not res) (null? (cdr args))) res))))))
  100.  
  101. (define <>                        ; <>
  102.   (lambda args
  103.     (cond ((null? (cdr args)) #T)
  104.       (else (do ((args args (cdr args))
  105.              (res #T (and res (<> (car args) (cadr args)))))
  106.             ((or (not res) (null? (cdr args))) res))))))
  107.  
  108. (define append                        ; APPEND
  109.   (letrec        ; for funarg use
  110.     ((append*
  111.       (lambda (args)
  112.     (cond ((null? args)
  113.            '())
  114.           ((null? (cdr args))
  115.            (car args))
  116.           ((null? (cddr args))
  117.            (%append (car args)(cadr args)))
  118.           (else
  119.            (%append (car args) (append* (cdr args))))))))
  120.     (lambda args
  121.       (append* args))))
  122.  
  123. (define append!                     ; APPEND!
  124.   (letrec        ; for funarg use
  125.     ((append!*        ; don't use DEFREC!
  126.       (lambda (args)
  127.     (cond ((null? args)
  128.            '())
  129.           ((null? (cdr args))
  130.            (car args))
  131.           ((null? (cddr args))
  132.            (append! (car args) (cadr args)))
  133.           (else
  134.            (append! (car args) (append!* (cdr args))))))))
  135.     (lambda args
  136.        (append!* args))))
  137.  
  138. (define bitwise-and                    ; BITWISE-AND, OR, XOR
  139.   (lambda (first . args)    ; force one argument
  140.     (do ((a first (bitwise-and a (car x)))
  141.      (x args (cdr x)))
  142.     ((null? x) a))))
  143.  
  144. (define bitwise-or
  145.   (lambda args
  146.     (if (null? args)
  147.     0
  148.     (do ((a (car args) (bitwise-or a (car x)))
  149.          (x (cdr args) (cdr x)))
  150.         ((null? x) a)))))
  151.  
  152. (define bitwise-xor
  153.   (lambda args
  154.     (if (null? args)
  155.     0
  156.     (do ((a (car args) (bitwise-xor a (car x)))
  157.          (x (cdr args) (cdr x)))
  158.         ((null? x) a)))))
  159.  
  160. (define char-ready?                    ; CHAR-READY?
  161.   (lambda args            ; for funarg uses
  162.     (char-ready? (car args))))    ; don't define with defrec!
  163.  
  164. (define display                     ; DISPLAY
  165.   (lambda (exp . rest)        ; for funarg uses
  166.     (display exp        ; don't define with defrec!
  167.          (car rest))))
  168.  
  169. (define list                        ; LIST
  170.   (lambda x x))   ; (for funarg use)
  171.  
  172. (define list*                        ; LIST*
  173.   (lambda x      ; (for funarg use)
  174.     (let loop ((x x))
  175.      (cond ((atom? x)    x)
  176.            ((atom? (cdr x)) (car x))
  177.            (else (cons (car x) (loop (cdr x))))))))
  178.  
  179. (define make-vector                    ; MAKE-VECTOR
  180.   (lambda (size . rest)  ; for funarg use, don't use DEFREC!
  181.     (let ((v (make-vector size)))
  182.       (when rest
  183.         (vector-fill! v (car rest)))
  184.       v)))
  185.  
  186. (define make-string                    ; MAKE-STRING
  187.   (lambda (size . rest)  ; for funarg use, don't use DEFREC!
  188.     (make-string size        ; don't define with defrec!
  189.          (car rest))))
  190.  
  191. (define max                        ; MAX
  192.   (lambda args    ; for funarg use, don't use DEFREC!
  193.     (if (null? args)
  194.     0
  195.     (do ((a (car args) (max a (car x)))
  196.          (x (cdr args) (cdr x)))
  197.         ((null? x) a)))))
  198.  
  199. (define min                        ; MIN
  200.   (lambda args    ; for funarg use, don't use DEFREC!
  201.     (if (null? args)
  202.     0
  203.     (do ((a (car args) (min a (car x)))
  204.          (x (cdr args) (cdr x)))
  205.         ((null? x) a)))))
  206.  
  207. (define newline                     ; NEWLINE
  208.   (lambda args            ; for funarg uses
  209.     (newline (car args))))    ; don't define with defrec!
  210.  
  211. (define prin1                        ; PRIN1
  212.   (lambda (exp . rest)        ; for funarg uses
  213.     (prin1 exp (car rest))))    ; don't define with defrec!
  214.  
  215. (define princ                        ; PRINC
  216.   (lambda (exp . rest)        ; for funarg uses
  217.     (princ exp (car rest))))    ; don't define with defrec!
  218.  
  219. (define print                        ; PRINT
  220.   (lambda (exp . rest)        ; for funarg uses
  221.     (print exp (car rest))))    ; don't define with defrec!
  222.  
  223. (define read-line                    ; READ-LINE
  224.   (lambda args            ; for funarg uses
  225.     (read-line (car args))))    ; don't define with defrec!
  226.  
  227. (define read-atom                    ; READ-ATOM
  228.   (lambda args            ; for funarg uses
  229.     (read-atom (car args))))    ; don't define with defrec!
  230.  
  231. (define read-char                    ; READ-CHAR
  232.   (lambda args            ; for funarg uses
  233.     (if (or (not args) (window? (car args)))
  234.     (let* ((win (if args (car args) (current-input-port)))
  235.            (pos (window-get-position win))
  236.            (cur (window-get-cursor win)))
  237.       (%esc 42 1 
  238.         (+ (car cur) (car pos))
  239.         (+ (cdr cur) (cdr pos)))
  240.       ((named-lambda (wait)    ; don't define with defrec!
  241.          (if (char-ready? (car args))
  242.          (begin (%esc 42 0)
  243.             (%read-char (car args)))
  244.          (wait)))))
  245.     (%read-char (car args)))))
  246.  
  247. (define unread-char                    ; UNREAD-CHAR
  248.   (lambda args            ; for funarg uses
  249.     (unread-char (car args))))    ; don't define with defrec!
  250.  
  251.                             ; STRING-APPEND
  252. ;; STRING-APPEND should be moved here from PCHREQ.S
  253. ;; (for funarg definition) for consistency
  254.  
  255. (define vector                        ; VECTOR
  256.   (lambda L
  257.     (list->vector L)))
  258.  
  259. (define write                        ; WRITE
  260.   (lambda (exp . rest)        ; for funarg uses
  261.     (write exp (car rest))))    ; don't define with defrec!
  262.  
  263. (define write-char                    ; WRITE-CHAR
  264.   (lambda (exp . rest)            ; for funarg uses
  265.     (write-char exp (car rest))))   ; don't define with defrec
  266.  
  267. (define %graphics                    ; %graphics (BGI)
  268.   (lambda (func . rest)                    ; at least one arg (required for return value)
  269.     (%execute (compile `(%graphics ,func ,@rest)))
  270.     *the-non-printing-object*))
  271.  
  272. (define %mouse                        ; %mouse
  273.   (lambda (func . rest)                    ; at least one arg (required for return value)
  274.     (%execute (compile `(%mouse ,func ,@rest)))))
  275.  
  276. (define %esc                        ; %esc (C functions)
  277.   (lambda (func . rest)
  278.     (%execute (compile `(%esc ,func ,@rest)))))
  279.  
  280.